home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2007 September / PCWSEP07.iso / Software / Linux / Linux Mint 3.0 Light / LinuxMint-3.0-Light.iso / casper / filesystem.squashfs / usr / share / perl / 5.8.8 / overload.pm < prev    next >
Encoding:
Perl POD Document  |  2007-03-05  |  4.2 KB  |  171 lines

  1. package overload;
  2.  
  3. our $VERSION = '1.04';
  4.  
  5. $overload::hint_bits = 0x20000; # HINT_LOCALIZE_HH
  6.  
  7. sub nil {}
  8.  
  9. sub OVERLOAD {
  10.   $package = shift;
  11.   my %arg = @_;
  12.   my ($sub, $fb);
  13.   $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
  14.   *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
  15.   for (keys %arg) {
  16.     if ($_ eq 'fallback') {
  17.       $fb = $arg{$_};
  18.     } else {
  19.       $sub = $arg{$_};
  20.       if (not ref $sub and $sub !~ /::/) {
  21.     $ {$package . "::(" . $_} = $sub;
  22.     $sub = \&nil;
  23.       }
  24.       #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
  25.       *{$package . "::(" . $_} = \&{ $sub };
  26.     }
  27.   }
  28.   ${$package . "::()"} = $fb; # Make it findable too (fallback only).
  29. }
  30.  
  31. sub import {
  32.   $package = (caller())[0];
  33.   # *{$package . "::OVERLOAD"} = \&OVERLOAD;
  34.   shift;
  35.   $package->overload::OVERLOAD(@_);
  36. }
  37.  
  38. sub unimport {
  39.   $package = (caller())[0];
  40.   ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
  41.   shift;
  42.   for (@_) {
  43.     if ($_ eq 'fallback') {
  44.       undef $ {$package . "::()"};
  45.     } else {
  46.       delete $ {$package . "::"}{"(" . $_};
  47.     }
  48.   }
  49. }
  50.  
  51. sub Overloaded {
  52.   my $package = shift;
  53.   $package = ref $package if ref $package;
  54.   $package->can('()');
  55. }
  56.  
  57. sub ov_method {
  58.   my $globref = shift;
  59.   return undef unless $globref;
  60.   my $sub = \&{*$globref};
  61.   return $sub if $sub ne \&nil;
  62.   return shift->can($ {*$globref});
  63. }
  64.  
  65. sub OverloadedStringify {
  66.   my $package = shift;
  67.   $package = ref $package if ref $package;
  68.   #$package->can('(""')
  69.   ov_method mycan($package, '(""'), $package
  70.     or ov_method mycan($package, '(0+'), $package
  71.     or ov_method mycan($package, '(bool'), $package
  72.     or ov_method mycan($package, '(nomethod'), $package;
  73. }
  74.  
  75. sub Method {
  76.   my $package = shift;
  77.   $package = ref $package if ref $package;
  78.   #my $meth = $package->can('(' . shift);
  79.   ov_method mycan($package, '(' . shift), $package;
  80.   #return $meth if $meth ne \&nil;
  81.   #return $ {*{$meth}};
  82. }
  83.  
  84. sub AddrRef {
  85.   my $package = ref $_[0];
  86.   return "$_[0]" unless $package;
  87.  
  88.     require Scalar::Util;
  89.     my $class = Scalar::Util::blessed($_[0]);
  90.     my $class_prefix = defined($class) ? "$class=" : "";
  91.     my $type = Scalar::Util::reftype($_[0]);
  92.     my $addr = Scalar::Util::refaddr($_[0]);
  93.     return sprintf("$class_prefix$type(0x%x)", $addr);
  94. }
  95.  
  96. *StrVal = *AddrRef;
  97.  
  98. sub mycan {                # Real can would leave stubs.
  99.   my ($package, $meth) = @_;
  100.   return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
  101.   my $p;
  102.   foreach $p (@{$package . "::ISA"}) {
  103.     my $out = mycan($p, $meth);
  104.     return $out if $out;
  105.   }
  106.   return undef;
  107. }
  108.  
  109. %constants = (
  110.           'integer'      =>  0x1000, # HINT_NEW_INTEGER
  111.           'float'      =>  0x2000, # HINT_NEW_FLOAT
  112.           'binary'      =>  0x4000, # HINT_NEW_BINARY
  113.           'q'      =>  0x8000, # HINT_NEW_STRING
  114.           'qr'      => 0x10000, # HINT_NEW_RE
  115.          );
  116.  
  117. %ops = ( with_assign      => "+ - * / % ** << >> x .",
  118.      assign          => "+= -= *= /= %= **= <<= >>= x= .=",
  119.      num_comparison      => "< <= >  >= == !=",
  120.      '3way_comparison'=> "<=> cmp",
  121.      str_comparison      => "lt le gt ge eq ne",
  122.      binary          => "& | ^",
  123.      unary          => "neg ! ~",
  124.      mutators      => '++ --',
  125.      func          => "atan2 cos sin exp abs log sqrt int",
  126.      conversion      => 'bool "" 0+',
  127.      iterators      => '<>',
  128.      dereferencing      => '${} @{} %{} &{} *{}',
  129.      special      => 'nomethod fallback =');
  130.  
  131. use warnings::register;
  132. sub constant {
  133.   # Arguments: what, sub
  134.   while (@_) {
  135.     if (@_ == 1) {
  136.         warnings::warnif ("Odd number of arguments for overload::constant");
  137.         last;
  138.     }
  139.     elsif (!exists $constants {$_ [0]}) {
  140.         warnings::warnif ("`$_[0]' is not an overloadable type");
  141.     }
  142.     elsif (!ref $_ [1] || "$_[1]" !~ /CODE\(0x[\da-f]+\)$/) {
  143.         # Can't use C<ref $_[1] eq "CODE"> above as code references can be
  144.         # blessed, and C<ref> would return the package the ref is blessed into.
  145.         if (warnings::enabled) {
  146.             $_ [1] = "undef" unless defined $_ [1];
  147.             warnings::warn ("`$_[1]' is not a code reference");
  148.         }
  149.     }
  150.     else {
  151.         $^H{$_[0]} = $_[1];
  152.         $^H |= $constants{$_[0]} | $overload::hint_bits;
  153.     }
  154.     shift, shift;
  155.   }
  156. }
  157.  
  158. sub remove_constant {
  159.   # Arguments: what, sub
  160.   while (@_) {
  161.     delete $^H{$_[0]};
  162.     $^H &= ~ $constants{$_[0]};
  163.     shift, shift;
  164.   }
  165. }
  166.  
  167. 1;
  168.  
  169. __END__
  170.  
  171.